{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  OboeLang.Parser
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Parser.
--
--------------------------------------------------------------------------------

module OboeLang.Parser 
  (
    parseMainModule
  , parseLibraryModule  
  , ParseError                  -- re-export
  ) where

import OboeLang.SyntaxBase
import OboeLang.TopSyntax
import OboeLang.Utils (emptyH, snocH)

import Text.Parsec                              -- package: parsec
import Text.Parsec.Error 
import Text.Parsec.Language
import Text.Parsec.Pos ( initialPos )
import Text.Parsec.String
import qualified Text.Parsec.Token as P

import Control.Applicative hiding ( (<|>), many, optional )
import Control.Monad.Identity
import qualified Data.IntMap as IntMap
import System.Directory

type OboeParser a       = ParsecT String () Identity a
type OboeLexer          = P.GenTokenParser String () Identity

parseMainModule :: FilePath -> IO (Either ParseError Module)
parseMainModule = safeParseFromFile mainModule

parseLibraryModule :: FilePath -> IO (Either ParseError Module)
parseLibraryModule = safeParseFromFile libraryModule

safeParseFromFile :: Parser a -> FilePath -> IO (Either ParseError a)
safeParseFromFile p file_path = do 
    b <- doesFileExist file_path
    if b then parseFromFile p file_path 
         else return (Left missing_error)
  where
    missing_error = newErrorMessage (SysUnExpect missing_text) 
                                    (initialPos file_path)
    missing_text  = "ERROR: cannot find file - " ++ file_path



mainModule :: OboeParser Module
mainModule = 
    (\name imports (orch,binds) -> Module { module_name = name
                                          , module_imports = imports
                                          , module_binds = binds
                                          , module_mb_orch = Just orch
                                          })
      <$> (whiteSpace *> moduleDecl) <*> many importDecl
                                     <*> oneAndMany orchDict binding

libraryModule :: OboeParser Module
libraryModule = 
    (\name imports binds -> Module { module_name = name
                                   , module_imports = imports
                                   , module_binds = binds
                                   , module_mb_orch = Nothing
                                   })
      <$> (whiteSpace *> moduleDecl) <*> many importDecl <*> many binding

moduleDecl :: OboeParser ModuleName
moduleDecl = reserved "module" *> moduleName <* reserved "where"



importDecl :: OboeParser ImportDecl
importDecl = fn <$> (reserved "import" *> moduleName) 
                <*> optionMaybe (reserved "as" *> ident)
  where
    fn s Nothing  = ImportTop s
    fn s (Just t) = ImportAlias s t


moduleName :: OboeParser ModuleName
moduleName = pModuleIdent >>= next
  where
    pModuleIdent = sepBy1 identifier (char '.')
    next parts   = case makeModuleNameL parts of 
                     Nothing -> parserFail "moduleName (impossible?)"
                     Just ans -> return ans


orchDict :: OboeParser OrchDict
orchDict = reserved "orch" *> reservedOp "=" *> body
  where
    body = IntMap.fromList <$> braces (commaSep numBinding)

numBinding :: OboeParser (Int,BindingRhs)
numBinding = (,) <$> int <*> (reservedOp "=" *> bindingRhs)


binding :: OboeParser Binding
binding = defbinding <|> simpleBinding

defbinding :: OboeParser Binding
defbinding = Binding <$> (reserved "def" *> ident) 
                     <*> (reservedOp "=" *> body)
  where
    body = BindsF <$> formExpr

simpleBinding :: OboeParser Binding
simpleBinding = Binding <$> ident <*> (reservedOp "=" *> bindingRhs)

bindingRhs :: OboeParser BindingRhs
bindingRhs = arglist >>= bindingRhsK 

bindingRhsK :: [Ident] -> OboeParser BindingRhs
bindingRhsK args = monDefn <|> pureDefn
  where
    monDefn   = BindsM args <$> doBlock
    pureDefn  = BindsP args <$> expression

arglist :: OboeParser [Ident]
arglist = pargs <|> return []
  where
    pargs = (reservedOp "\\" *> many1 ident) <* reservedOp "->"

declaration :: OboeParser Decl
declaration = Decl <$> ident <*> (reservedOp "=" *> expression)

formExpr :: OboeParser FormExpr
formExpr = exprExtension

-- | Composition operator changed to &...
exprExtension       :: OboeParser FormExpr
exprExtension       = chainl1 formExpr1 (FormExtension <$ reservedOp "@")

formExpr1           :: OboeParser FormExpr
formExpr1           = exprPrim <|> exprNamed

exprPrim            :: OboeParser FormExpr
exprPrim            = PrimForm <$> braces (commaSep binding)

exprNamed           :: OboeParser FormExpr
exprNamed           = FormName <$> ident

--------------------------------------------------------------------------------
-- Do expressions

doBlock :: OboeParser DoBlock
doBlock = doMulti <|> doSingle
  where
    doMulti  = reserved "do" *> braces (semiSep doStmt)
    doSingle = (\a -> [a]) <$> doStmt


doStmt :: OboeParser Stmt
doStmt = pReturn <|> pDoLet <|> pDoLam <|> pDoIf <|> doAction
  where
    pReturn   = Return  <$> (reserved "return" *> expression)
    pDoLet    = DoLet   <$> (reserved "let"    *> declaration)
    pDoLam    = DoLam   <$> (reserved "letfun" *> ident)
                        <*> many1 ident
                        <*> (reservedOp "=" *> doBlock)
    pDoIf     = DoIf    <$> (reserved "if" *> expression)
                        <*> (reserved "then" *> doBlock)
                        <*> (reserved "else" *> doBlock)

-- | var id is common prefix
-- 
doAction :: OboeParser Stmt
doAction = varBind >>= step
  where
    step (Bind1 vid)    =  DoBind (Bind1 vid) <$> (reservedOp "<-" *> doBlock)
                       <|> PrimCall vid <$> commaSep expression

    step tup            = DoBind tup <$> (reservedOp "<-" *> doBlock)


varBind :: OboeParser VarBind
varBind = varTup <|> var1
  where
    varTup = BindTuple <$> parens (commaSep ident)
    var1   = Bind1     <$> ident 


-- Possibly we can live with this one (not sure if general 
-- application will be supported):
--
expression :: OboeParser Expr
expression = expression10 <?> "expression"


expression10 :: OboeParser Expr
expression10 =  try pAppPure     -- backtrack otherwise ident is a common prefix
            <|> expression9
  where
    pAppPure = App  <$> ident <*> parens (commaSep expression)

-- Record projection is treated as a indetifier and resolved later.
-- This is a bad hack - cannot project on anonymous records, but
-- it is good enough for now.

expression9 :: OboeParser Expr
expression9 =  pCond 
           <|> expression8
  where
    pCond = Cond <$> (reserved "cond" *> expression) 
                 <*> (reservedOp "?"  *> expression)
                 <*> (reservedOp ":"  *> expression)


-- | No (^) power-of operator - use is discouraged in Csound.
--
expression8 :: OboeParser Expr
expression8 = expression7

-- | (*) and (/) left assoc
--
expression7 :: OboeParser Expr
expression7 =  UnaryE <$> uNeg <*> expression
           <|> chainl1 expression6 (BinE <$> pOps)
  where
    uNeg  =  NEG <$ reservedOp "-"
    pOps  = (MUL <$ reservedOp "*") <|> (DIV <$ reservedOp "/")

    -- also unary negate

-- | (+) and (-) left assoc
--
expression6 :: OboeParser Expr
expression6 = chainl1 expression5 (BinE <$> p)
  where
    p = (ADD <$ reservedOp "+") <|> (SUB <$ reservedOp "-")


-- | No list operators (no lists)
--
expression5 :: OboeParser Expr
expression5 = expression4


expression4 :: OboeParser Expr
expression4 = chainl1 expression3 (RelE <$> p)
  where
    p = choice [ EQU            <$ reservedOp "=="
               , NEQU           <$ reservedOp "/="
               , LESSTHAN       <$ reservedOp "<"
               , GREATTHAN      <$ reservedOp ">"
               , LTEQU          <$ reservedOp "<="
               , GTEQU          <$ reservedOp ">="
               ]

expression3 :: OboeParser Expr
expression3 = chainr1 expression2 (BinE <$> pLogAdd)
  where
    pLogAdd = LOG_AND <$ reservedOp "&&"

expression2 :: OboeParser Expr
expression2 = chainr1 expression1 (BinE <$> pLogOr)
  where
    pLogOr  = LOG_OR <$ reservedOp "||"

expression1 :: OboeParser Expr
expression1 = primitiveExpression


primitiveExpression :: OboeParser Expr 
primitiveExpression = literalExpr <|> parensExpr <|> variableExpr


parensExpr :: OboeParser Expr
parensExpr = disamb <$> parens (commaSep expression)
  where
    -- Do we need nil () ?
    disamb [e] = e
    disamb es  = Tuple es


variableExpr :: OboeParser Expr
variableExpr = Var <$> ident



literalExpr :: OboeParser Expr
literalExpr = Lit <$> choice [ floatLit, intLit, stringLit, boolLit ]
           <?> "literal"  
  where 
    intLit      = Int    <$> int
    floatLit    = Float  <$> decimal
    stringLit   = String <$> stringl
    boolLit     = Bool   <$> bool


--------------------------------------------------------------------------------
-- Identifiers


ident                   :: OboeParser Ident
ident                   = Ident <$> identifier


--------------------------------------------------------------------------------
-- Tokens
--------------------------------------------------------------------------------



ochre_lex           :: OboeLexer
ochre_lex           = P.makeTokenParser ochre_def

parens              :: OboeParser a -> OboeParser a
parens              = P.parens ochre_lex 


braces              :: OboeParser a -> OboeParser a
braces              = P.braces ochre_lex

-- brackets            :: OboeParser a -> OboeParser a
-- brackets            = P.brackets ochre_lex

-- | skips trailing space
-- semi                :: OboeParser String
-- semi                = P.semi ochre_lex

semiSep             :: OboeParser a -> OboeParser [a]
semiSep             = P.semiSep ochre_lex


-- semiSep1            :: OboeParser a -> OboeParser [a]
-- semiSep1            = P.semiSep1 ochre_lex

commaSep            :: OboeParser a -> OboeParser [a]
commaSep            = P.commaSep ochre_lex

-- commaSep1           :: OboeParser a -> OboeParser [a]
-- commaSep1           = P.commaSep1 ochre_lex


identifier          :: OboeParser String
identifier          = P.identifier ochre_lex

-- stringLiteral       :: OboeParser String
-- stringLiteral       = P.stringLiteral ochre_lex

symbol              :: String ->  OboeParser String
symbol              = P.symbol ochre_lex

reserved            :: String ->  OboeParser ()
reserved s          = P.reserved ochre_lex s
                   <?> "reserved: " ++ s

reservedOp          :: String -> OboeParser ()
reservedOp          = P.reservedOp ochre_lex

int                 :: OboeParser Int
int                 = fromIntegral <$> P.integer ochre_lex

decimal             :: OboeParser Decimal
decimal             = realToFrac <$> try (P.float ochre_lex)

stringl             :: OboeParser String
stringl             = P.stringLiteral ochre_lex

bool                :: OboeParser Bool
bool                = true <|> false
  where
    true  = True  <$ symbol "True"
    false = False <$ symbol "False"

-- pfield              :: OboeParser Int
-- pfield              = fromIntegral <$> try (string "p" *> P.integer ochre_lex)

whiteSpace          :: OboeParser ()
whiteSpace          = P.whiteSpace ochre_lex

--------------------------------------------------------------------------------
-- Lang def
--------------------------------------------------------------------------------


-- | Note - allow super prefix @super:@ in identifiers.
--
-- All other occurances of @:@ are an error but go unchecked.
--
ochre_def :: LanguageDef st
ochre_def = haskellStyle
    { P.identStart        = letter   <|> oneOf "'"
    , P.identLetter       = alphaNum <|> oneOf "_:#"
    , P.reservedOpNames   = [ "&", "<-", "=", "*"
                            , "/", "+", "-", "@"
                            , ":", "\\", "->"
                            ]  
    , P.reservedNames     = [ "module", "where"
                            , "import", "as"
                            , "orch", "def"
                            , "do", "let", "letfun"
                            , "cond", "return"
                            , "if", "then", "else"
                            --
                            -- Builtins
                            , "builtins"
                            --
                            -- types
                            , "Any", "String", "Int", "Float"
                            , "ASig", "KSig", "ISig"
                            , "Cs" 
                            ] 
    }



--------------------------------------------------------------------------------

oneAndMany :: OboeParser a -> OboeParser b -> OboeParser (a,[b])
oneAndMany p q = outer emptyH
  where
    outer ac = do { ans <- optionEither p q
                  ; case ans of
                      Left a -> inner ac a 
                      Right b -> outer (ac `snocH` b)
                  }
    inner ac a = final ac a <$> many q
    
    final ac a xs = (a, ac $ xs)

-- Wasn\'t this in Parsec...
optionEither :: OboeParser a -> OboeParser b -> OboeParser (Either a b)
optionEither p q = (Left <$> p) <|> (Right <$> q)
    